perm filename TYPES.LSP[SCH,LSP] blob sn#688855 filedate 1982-11-14 generic text, type T, neo UTF8
;;; -*-LISP-*-

(HERALD TYPES "")

(eval-when (compile) (load "scm:umacro"))
(eval-when (compile) (load "scm:smacro"))

;;; Identifying object types

(DEFUN-IMPORT primitive-type (object)
  (cond  ((numberp object)			'NUMBER)
	 ((null object)				'NULL)
	 ((symbolp object)			'SYMBOL)
	 ((pairp object)			'PAIR)
	 ((hunkp object)
	  (caseq (object-type object)
	    (*array*				'ARRAY)
	    (*control-point*			'CONTROL-POINT)
	    (*procedure*
	     (let ((name-field (procedure-name object)))
	       (cond ((atom? name-field)
		      				'COMPOUND-PROCEDURE)
		     ((eq (car name-field)
			  '&advised-primitive-procedure)
			     			'PRIMITIVE-PROCEDURE)
		     (t 			'COMPOUND-PROCEDURE))))
	    ((SUBR LSUBR UNFORCED-SUBR
	      UNFORCED-LSUBR
	      BUT-1-FORCED-SUBR EXPR)
	     					'PRIMITIVE-PROCEDURE)
	    (*ENVIRONMENT* 			'ENVIRONMENT)
	    (*delayed*                          'DELAYED-OBJECT)
	    (T 'Unidentified-Object)))
	 (T 'Unidentified-Object)))

(DEFUN-IMPORT list? (object)
  (or (null object) (pairp object)))

;;; ATOM? defined in UPROCS

(DEFUN-IMPORT (applicable? sch-applicable?) (object)
  (or (eq (primitive-type object) 'COMPOUND-PROCEDURE)
      (eq (primitive-type object) 'PRIMITIVE-PROCEDURE)))

(DEFUN-IMPORT (environment? sch-environment?) (object)
  (environment? object))

(ADD-TO-LISP-IMPORTS
 '((EQ? EQ)
   (SYMBOL? SYMBOLP) (NUMBER? NUMBERP)
   (PAIR? PAIRP) (EXTEND? HUNKP) (HUNK? HUNKP)
   (NULL? NULL) (NIL? NULL)))


(ADD-TO-LISP-IMPORTS
 '(RPLACX CXR HUNK HUNKSIZE))

(ADD-TO-LISP-IMPORTS
 '((alphaless? alphalessp) gensym intern maknam readlist
   filep mergef namestring deletef))


;;; Environment Hacking


(DEFUN-IMPORT (frame-formals sch-frame-formals) (env)
  (frame-formals env))

(DEFUN-IMPORT (frame-arguments sch-frame-arguments) (env)
  (frame-arguments env))

(DEFUN-IMPORT (aux-variables sch-aux-variables) (env)
  (aux-variables env))

(DEFUN-IMPORT (aux-values sch-aux-values) (env)
  (aux-values env))

(DEFUN-IMPORT (frame-procedure sch-frame-procedure) (env)
  (frame-procedure env))

(DEFUN-IMPORT (frame-parent sch-previous-frame) (env)
  (previous-frame env))

(DEFUN-IMPORT frame-bindings (env)
  (nconc
   (mapcar '(lambda (formal arg) (list formal arg))
	   (frame-formals env)
	   (frame-arguments env))
   (mapcar '(lambda (var val) (list var val))
	   (aux-variables env)
	   (aux-values env))))

;;; environment probes.

(DEFUN-IMPORT locally-defined? (frame var)
  (or (memq var (aux-variables frame))
      (memq var (frame-formals frame))))

(DEFUN-IMPORT defined? (env var)
  (do ((fr env (previous-frame fr)))
      ((null fr)
       (globally-bound? var))
    (cond ((locally-defined? fr var)
	   (return t)))))


;;; Procedure Hacking

(DEFUN-IMPORT (SET-PROCEDURE-CLASS SCH-SET-PROCEDURE-CLASS) (PROC VAL)
  (SET-PROCEDURE-CLASS PROC VAL))

(DEFUN-IMPORT (SET-PROCEDURE-OBJECT SCH-SET-PROCEDURE-OBJECT) (PROC OBJECT)
  (SET-PROCEDURE-OBJECT PROC OBJECT))

(DEFUN-IMPORT (SET-PROCEDURE-NAME SCH-SET-PROCEDURE-NAME) (PROC NAME)
  (SET-PROCEDURE-NAME PROC NAME))

(DEFUN-IMPORT (SET-PROCEDURE-ENVIRONMENT SCH-SET-PROCEDURE-ENVIRONMENT) (PROC ENV)
  (SET-PROCEDURE-ENVIRONMENT PROC ENV))

(eval-when (compile) (load "scm:amacro"))

(DEFUN-IMPORT (procedure-name sch-procedure-name) (proc)
  (let ((name-field (procedure-name proc)))
    (if (atom? name-field) ; unadvised
	name-field
	(advised-name name-field))))

(defmacro direct-formals (proc)
  `(let ((formals-field 
	  (cond ((eq (object-type ,proc) '*procedure*)
		 (formal-parameters ,proc))
		(t
		 nil))))
     (cond ((eq (car formals-field) '&rest)
	    (cadr formals-field))
	   (t
	    formals-field))))

(defun direct-procedure-formals (proc) (direct-formals proc))

(DEFUN-IMPORT (procedure-formals sch-procedure-formals) (proc)
  (let ((name-field (procedure-name proc)))
    (cond ((atom? name-field)
	   (direct-formals proc))
	  (t (sch-procedure-formals (advised-proc name-field))))))

(defmacro direct-procedure-body (proc)
  `(cond ((eq (object-type ,proc) '*procedure*)
	  (cddr (unsyntax-procedure-definition ,proc)))
	 (t
	  nil)))

(DEFUN-IMPORT (procedure-body sch-procedure-body) (proc)
  (let ((name-field (procedure-name proc)))
    (cond ((atom? name-field)	; unadvised
	   (direct-procedure-body proc))
	  (t
	   (sch-procedure-body (advised-proc name-field))))))

(defmacro direct-procedure-environment (proc)
  `(cond ((eq (object-type ,proc) '*procedure*)
	  (procedure-environment ,proc))
	 (t
	  nil)))

(DEFUN-IMPORT (procedure-environment sch-procedure-environment) (proc)
  (let ((name-field (procedure-name proc)))
    (cond ((atom? name-field)	; unadvised
	   (direct-procedure-environment proc))
	  (t
	   (sch-procedure-environment proc)))))